/* Wrap Clean nodes (for debugging purposes). Version 1.0.5 Arjen van Weelden arjenw@cs.ru.nl Ronny Wichers Schreur ronny@cs.ru.nl */ implementation module ClosureWrap import StdEnv import Wrap // check whether all functions have descriptors closureHasDescriptor :: Bool closureHasDescriptor =: use_ea_entry_f && has_descriptor f where f => [] // make sure an ea entry is generated for f use_ea_entry_f = const True [f] // test whether f has a descriptor, because f has an ea entry the // compiler will have generated a null descriptor in case the // real descriptor for f is not needed (memory profiling is off // and dynamics are disabled) has_descriptor :: a -> Bool has_descriptor _ = code { |A| closure |B| pushI 8 |B| 8 pushD_a 0 |B| n_entry | 8 subI |B| n_entry-8 push_b_a 0 |A| n_entry-8 | closure pop_b 1 |B| pushD_a 0 |B| [n_entry-8]=desc pop_a 2 |A| pushI 4294967295 | (1<<32)-1 and% pushI 0 |B| 0 | desc eqI |B| desc == 0 notB } closureDeepWrapNode :: .a -> ClosureDeeplyWrappedNode closureDeepWrapNode node = wrap node instance wrap ClosureWrappedArg where wrap x = {closurearg = wrap x} instance wrap (ClosureWrappedNode a) | wrap a where wrap x = mapWrapClosureNode wrapArg (closureShallowWrapNode x) where wrapArg :: !UnwrappedArg -> a | wrap a wrapArg arg = wrap arg.node mapWrapClosureNode :: (a -> b) (ClosureWrappedNode a) -> ClosureWrappedNode b mapWrapClosureNode f (Closure desc args unboxed) = Closure desc {f e \\ e <-: args} unboxed mapWrapClosureNode f (NotAClosure node) = NotAClosure (mapWrapNode f node) closureShallowWrapNode :: .a -> ClosureShallowlyWrappedNode closureShallowWrapNode node = code { pushI 2 |B| 2 pushD_a 0 |B| node-desc | 2 and% |B| node-desc bitand 2 pushI 2 |B| 2 | node-desc bitand 2 eqI |B| 2 == node-desc bitand 2 jmp_false is_a_closure |B| create |A| | node | result push_a 1 |A| node | | node | result update_a 1 2 |A| node | | arg | result updatepop_a 0 1 |A| node | | result .d 2 0 jsr e_Wrap_sshallowWrap |A| WNode node | result .o 1 0 fill_r e_ClosureWrap_kNotAClosure 1 0 1 0 0 pop_a 1 |A| WNotAClos (WNode node) .d 1 0 rtn :is_a_closure pushI 4 |B| 4 pushD_a 0 |B| n-entry | 4 subI |B| n-entry - 4 push_b_a 0 |A| n-entry-4 | node | result pop_b 1 |B| pushD_a 0 |B| [n-entry-4]=arity pop_a 1 |A| node | result pushI 4294967295 | (1<<32)-1 and% pushI 0 |B| 0 | arity push_b 1 |B| arity | 0 | arity ltI |B| arity < 0 | arity jmp_false pos_arity |B| arity pop_b 1 |B| pushI 1 |B| 1=arity |.d 2 1 i :pos_arity pushI 8 |B| 8 | arity push_b 1 |B| arity | 8 | arity shiftrU |B| (arity / 256)=unboxed | arity pushI 255 |B| 255 | unboxed | arity push_b 2 |B| arity | 255 | unboxed | arity and% |B| arity bitand 255 | unboxed | arity update_b 1 2 |B| (arity bitand 255) | unboxed | unboxed subI |B| (arity bitand 255 - unboxed)=boxed | unboxed pushI 8 |B| 8 | boxed | unboxed pushD_a 0 |B| n-entry | 8 | boxed | unboxed subI |B| n-entry - 8 | boxed | unboxed push_b_a 0 |A| n-entry-8 | node | result pop_b 1 |B| boxed | unboxed pushD_a 0 |B| [n-entry-8] | boxed | unboxed pop_a 1 |A| node | result pushI 4294967295 | (1<<32)-1 and% pushI 2 |B| 2 | [n-entry-8] | boxed | unboxed addI |B| ([n-entry-8] + 2)=desc | boxed | unboxed | test for null descriptor pushI 2 |B| 2 | desc | boxed | unboxed push_b 1 |B| desc | 2 | desc | boxed | unboxed eqI |B| desc == 2 | desc | boxed | unboxed jmp_true no_descriptor |B| desc | boxed | unboxed | even if the descriptor is not null, it's not guaranteed that there | is a descriptor, we make a pessimistic estimate here .d 0 0 jsr e_ClosureWrap_sclosureHasDescriptor .o 0 1 b jmp_false no_descriptor |.o 2 3 iii :has_descriptor build_r e_Wrap_rWrappedDescriptorId 0 1 0 0 |A| wdescid | node | result build_r e_Wrap_kWrappedDescriptorOther 1 0 0 0 |A| wdesc | wdescid | {args} | wrapNodeStrict node | result updatepop_a 0 1 |A| wdesc | {args} | wrapNodeStrict node | result pop_b 1 |B| boxed | unboxed jmp wrap_args :no_descriptor pop_b 1 |B| boxed | unboxed buildh e_Wrap_dWrappedDescriptorUnknown 0 jmp wrap_args :wrap_args push_b 0 |B| boxed | boxed | unboxed create_array_ _ 1 0 |A| {(WrappedNode * boxed)=args} | wdesc | node | result ||B| boxed | unboxed pushI 0 |B| 0 | boxed | unboxed |.o 3 4 iiii :args_loop |A| {args} | wdesc| node | result ||B| i | desc | boxed | unboxed push_b 1 |B| boxed | i | boxed | unboxed push_b 1 |B| i | boxed | i | boxed | unboxed ltI |B| i < boxed | i | boxed | unboxed jmp_false args_done |B| i | boxed | unboxed pushI 32 pushI 4294967296 | 1<<32 shiftr% | (1<<32)>>32 pushI 2 addI | 2 if 32 bits, 3 if 64 bits push_b 1 |B| i | 2 | i | boxed | unboxed incI |B| i + 1 | 2 | i | boxed | unboxed shiftl% |B| i * 4 + 4 | i | boxed | unboxed push_a_b 2 |B| addr node | i * 4 + 4 | i | boxed | unboxed addI |B| addr node + i * 4 + 4 | i | boxed | unboxed push_b_a 0 |A| node+i*4+4 | {args} | wdesc | node | result pop_b 1 |B| i | boxed | unboxed pushD_a 0 |B| [node+i*4+4] | i | boxed | unboxed pop_a 1 |A| {args} | wdesc | node | result push_b_a 0 |A| [node+i*4+4] | {args} | wdesc node | result pop_b 1 |B| i | boxed | unboxed build_r e_Wrap_rUnwrappedArg 1 0 0 0 updatepop_a 0 1 | build e_Wrap_tUnwrappedArg 1 e_Wrap_cUnwrappedArg push_a 1 |A| {args} | wrappedNode | {args} | wdesc | node | result update_a 1 2 |A| {args} | wrappedNode | wrappedNode | wdesc | node | result updatepop_a 0 1 |A| {args} | wrappedNode | wdesc | node | result push_b 0 |B| i | i | boxed | unboxed update _ 1 0 |A| {args & [i] = wrappedNode} | wdesc | node | result ||B| i | boxed | unboxed incI |B| i + 1 | boxed | unboxed |.d 3 4 iiii jmp args_loop |.o 3 4 iiii :args_done |A| {args} | wdesc | node | result ||B| i | boxed | unboxed pop_b 2 |B| unboxed update_a 0 2 |A| {args} | wdesc | {args} | result pop_a 1 |A| wdesc | {args} | result fill_r e_ClosureWrap_kClosure 2 1 2 0 0 |A| WDescId desc | {args} | WClosure wdesc {args} unboxed pop_b 1 |B| pop_a 2 |A| WOther wdesc {args} unboxed }