( -*- forth -*- ) ( BADNOP dev env for PICmicro 18fxx2 ) ( ********** 18f452 FORTH MACROS ************ ) ( What you find here is the code generator for the 18fxx2 architecture, implemented as a collection of target macros. Basicly, it maps the architecture to forth. Code below is full of target specific tricks. This was originally part of the badnop project, but ported to mole. All words ending with a '_' character are by convention words that generate target code at the current target assembly point. ( import symbolic constants ) load 18f452.f ( INSTRUCTION SET ) ( 18fxx2 opcodes ) : andwf 0x1400 ; : addwf 0x2400 ; : subwf 0x5C00 ; : decf 0x0400 ; : incf 0x0400 ; ( FIX ME ! ) : xorwf 0x1800 ; : iorwf 0x1000 ; : movwf 0x6E00 ; : movf 0x5000 ; : movlw 0x0E00 ; : movff 0xC000 ; : addlw 0x0F00 ; : sublw 0x0800 ; : andlw 0x0B00 ; : xorlw 0x0A00 ; : iorlw 0x0900 ; : push 0x0005 ; : pop 0x0006 ; : bz 0xE000 ; : bov 0xE400 ; : bnov 0xE500 ; : bnn 0xE700 ; : bnc 0xE300 ; : bn 0xE600 ; : bc 0xE200 ; : bnz 0xE100 ; : bra 0xD000 ; : rcall 0xD800 ; : nop 0x0000 ; : nopf 0xf000 ; ( nop used as extension word for 2 word ins ) : return 0x0012 ; : retfie 0x0010 ; : call 0xEC00 ; : goto 0xEF00 ; : lfsr 0xEE00 ; ( instruction opcode modifiers : inclusive or masks ) : w/ ; ( destination wreg DEFAULT ) : reg/ 0x0200 or ; ( destination freg ) : access/ ; ( access bank DEFAULT ) : banked/ 0x0100 or ; ( bsr bank ) : op/ 0xff and or ; ( add operand to instruction ) : sop/ swap op/ ; ( forth opcodes ) : op-drop movf POSTDEC0 op/ w/ ; : op-dup movwf PREINC0 op/ reg/ ; ( peephole optimization for certain instructions: -- stack movement optimization: makes sense since usually dup/drop is an explicit instruction -- tail call optimisation: necessary for proper usage of tail recursion -- literal folding. more so: ! and @ only support literal arguments the optimizer is very simple: just emit code for each word in a colon definition if there is no possible optimization, else undo a previous compilation and combine it's effect with the current one. ) ( instruction undo stacks ) stack last-dup stack last-drop stack last-lit stack last-call : record there swap stack-push ; ( record current there on stack ) : top=last? ( stack -- T/F ) stack-top there 2 - = ; ( compare top of peephole stack to previous there ) : top=lastbig? ( stack -- T/F ) stack-top there 4 - = ; ( same but for 2word instructions ) : opti-reset ( turn off peephole optimization this needs to be called at jump targets: i.e. next and docolon ) last-dup stack-reset last-drop stack-reset last-lit stack-reset last-call stack-reset ; : :start opti-reset ; ( start target colon word hook ) ( MACROS - map forth to assembler ) ( utilities and small instructions ) : undo -2 target-allot ; ( undo compilation of last instruction ) : undo there 2 - !there ; : movff ( src dst -- ) swap 0xfff and movff or _ 0xfff and nopf or _ ; : lfsr_ ( value reg -- ) >r dup 8 >> 0x0f and lfsr r> 4 << or or _ ( compile first word ) 0xff and nopf or _ ; ( compile second word ) : nop_ nop _ ; : push_ push _ ; : pop_ pop _ ; ( nop tags ) ( used in 2-ins words, but we can use it to tag executable code with a 12 bit ID ) : tag_ 0xf000 or _ ; : bad_ 0xbad tag_ ; ( stack manips ) : silentdrop_ POSTDEC0 WREG movff_ ; ( does not affect flags ) : test_ andlw 0xff or _ ; ( test Z and N flags from word on tos ) : >flags_ test_ silentdrop_ ; ( drop/save and opti ) : dup_ last-dup record op-dup _ ; ( record last dup ) : got-dup? last-dup top=last? ; : undo-dup undo last-dup stack-drop ; : drop_ got-dup? if undo-dup ;; then last-drop record op-drop _ ; ( else record and compile ) : got-drop? last-drop top=last? ; : undo-drop undo last-drop stack-drop ; : save_ got-drop? not if dup_ ;; then undo-drop ; ( jump/call/ret and opti ) : got-call? last-call top=lastbig? ; ( check if last instruction was a call ) : tailcall_ ( turn last call into a tail call ) there 4 - t@ 0xfff and goto or there 4 - t! last-call stack-drop ; : ;_ got-call? if tailcall_ ;; then return _ ; ( compile a tail call or a return ) : ;;_ ;_ ; ( fog ) : blong_ ( operands opcode -- ) ( compile a 2word long branch instruction ) >r 2 / dup ( save opcode and convert to word addressing ) 0xff and r> or _ 8 >> 0xff and nopf or _ ; : call_ last-call record call blong_ ; : jump_ goto blong_ ; ( literal and optimization there are only 2 possible code transformations: /dup lit/ -> // undo the lit completely /lit/ -> /drop/ undo an optimized lit the drop can be undone by a following save_ ) : lit_ save_ last-lit record ( save there for opti ) movlw sop/ _ ; : lit2_ ( _ two byte literal ) dup lit_ 8 >> lit_ ; : get-lit ( get literal from last instruction ) there 2 - t@ 0xff and ; : got-lit? last-lit top=last? ; ( last instruction a literal? ) : undo-lit undo last-lit stack-drop ( undo movlw ) got-dup? if undo-dup ;; then ( "dup lit" -> "" ) drop_ ; ( "lit" -> "drop" ) : not-lit? got-lit? not ; : re-lit get-lit undo-lit ; ( get literal and undo literal compilation ) load 18f452_mac.f ( load symbolic name macros after lit_ is defined ) ( load / store primitives ) : litstore_ movwf sop/ _ ; : lit!_ litstore_ drop_ ; : litload_ movf sop/ _ ; : lit@_ save_ litload_ ; ( b reg macros for stack load/store note: you are better off using address regs directly instead of using addresses on the stack_ which use the b reg ) : >>b_ FSR2H lit!_ FSR2L lit!_ ; : stack@_ >>b_ INDF2 lit@_ ; : stack!_ >>b_ INDF2 lit!_ ; ( optimizing macros ) : !_ not-lit? if stack!_ ;; then ( prev inst not a literal? -> not supported ) re-lit ( load lit value on DS and undo lit instruction ) got-dup? not if lit!_ ;; then ( no dup -> compile a store+drop ) undo-dup litstore_ ; ( dup -> undo dup and compile store ) : @_ not-lit? if stack@_ ;; then re-lit save_ litload_ ; ( TOS words ) : neg_ sublw _ ; : not_ xorlw 0xff op/ _ ; ( 2 argument words operating on TOS and 2nd ) : 2op_ POSTDEC0 op/ _ ; ( compile stack 2op instruction ) : real+_ addwf 2op_ ; : real-_ subwf 2op_ ; : realxor_ xorwf 2op_ ; : realand_ andwf 2op_ ; : realor_ iorwf 2op_ ; ( arithmic operating on TOS and immediate ) : lit+_ addlw sop/ _ ; ( compile literal add ) : lit-_ neg lit+_ ; ( literal sub ) : litxor_ xorlw sop/ _ ; : litand_ andlw sop/ _ ; : litor_ iorlw sop/ _ ; ( operating on TOS and reg_ result in TOS ) : @2op_ sop/ _ ; : lit@+_ addwf @2op_ ; : lit@-_ subwf @2op_ ; : lit@xor_ xorwf @2op_ ; : lit@or_ iorwf @2op_ ; : lit@and_ andwf @2op_ ; ( operating on TOS and reg_ result in reg + drop ) : 2op!_ sop/ reg/ _ drop_ ; : lit+!_ addwf 2op!_ ; : lit-!_ subwf 2op!_ ; : litxor!_ xorwf 2op!_ ; : litor!_ iorwf 2op!_ ; : litand!_ andwf 2op!_ ; ( do literal constant ) : +_ not-lit? if real+_ then re-lit lit+_ ; : -_ not-lit? if real-_ then re-lit lit-_ ; : or_ not-lit? if realor_ then re-lit litor_ ; : xor_ not-lit? if realxor_ then re-lit litxor_ ; : and_ not-lit? if realand_ then re-lit litand_ ; ( do literal register load ) : @+_ not-lit? if stack@_ real+_ ;; then re-lit lit@+_ ; : @-_ not-lit? if stack@_ real-_ ;; then re-lit lit@-_ ; : @or_ not-lit? if stack@_ realor_ ;; then re-lit lit@or_ ; : @xor_ not-lit? if stack@_ realxor_ ;; then re-lit lit@xor_ ; : @and_ not-lit? if stack@_ realand_ ;; then re-lit lit@and_ ; ( do literal register store ) : +!_ not-lit? if real+_ stack!_ ;; then re-lit lit+!_ ; : -!_ not-lit? if real-_ stack!_ ;; then re-lit lit-!_ ; : or!_ not-lit? if realor_ stack!_ ;; then re-lit litor!_ ; : xor!_ not-lit? if realxor_ stack!_ ;; then re-lit litxor!_ ; : and!_ not-lit? if realand_ stack!_ ;; then re-lit litand!_ ; : incf_ incf sop/ reg/ _ ; : decf_ decf sop/ reg/ _ ; ( return stack 'local variables' ) : rl_ TOSL_ ; : rh_ TOSH_ ; ( for counters ) : rl++_ TOSL incf_ ; : rl--_ TOSL decf_ ; : rh++_ TOSH incf_ ; : rh--_ TOSH decf_ ; ( push/pop might block opti?? ) : loop_ push_ rl--_ rl--_ ; ( push location ) : >r_ push_ rl_ !_ ; ( move byte to/from return stack ) : r>_ rl_ @_ pop_ ; : >>r_ push_ rh_ !_ rl_ !_ ; ( move word to/from return stack ) : r>>_ rl_ @_ rh_ @_ pop_ ; : rdrop_ pop_ ; : TMP 0x10 ; ( temporary register. needs to be saved during interrupts ) : TMP_ TMP lit_ ; : swap_ ( 4 cycles.. ) INDF0 TMP movff_ movwf INDF0 op/ _ movf TMP op/ _ ; ( conditional blocks use the machine flags ) : encode-srcdst ( to from -- jmpoperand ) - ( distance ) 2 - ( - 2 to compensate for PC inc. ) 2 / ; ( instruction uses word addressing ) : offset-to there encode-srcdst ; ( compute branch offset there->address ) : offset-from there swap encode-srcdst ; ( address->there ) : rjump_ offset-to 0x7ff and bra or _ ; ( short relative jump ) : rcall_ offset-to 0x7ff and rcall or _ ; ( short relative call ) : op-cjump ( address opcode -- packedopcode ) ( create conditional jump opcode ) >r offset-to 0xff and r> or ; : patch-cjump_ ( addr ) dup offset-from 0xff and >r ( compute relative distance ) dup t@ ( get opcode ) 0xff00 and r> or ( strip address and insert new ) swap t! ; ( store instruction ) : for_ >r_ there ( move count to r_ save there on compiler stack ) opti-reset ; ( disable peephole opti ) : next_ ( decrement value in TOSL and branch back if nonzero ) rl--_ bnz op-cjump _ pop _ ; : ifnz_ there bz _ ; : ifz_ there bnz _ ; : ifc_ there bnc _ ; : ifnc_ there bc _ ; : ifn_ there bnn _ ; : ifnn_ there bn _ ; : ifov_ there bnov _ ; : ifnov_ there bov _ ; : skip_ there bra _ ; : if_ >flags_ ifnz_ ; ( proper if uses tos. use flag ifs if possible. they are faster ) : then_ ( can be used to patch any conditional reljump ) patch-cjump_ ( it can patch forward bra too ) opti-reset ; : else_ ( patch first cond jump and set new uncond ) skip_ >r patch-cjump_ r> ; ( indirect addressing uses FSR1_FSR2 : the 'a' and 'b' registers ) ( register aliases ) ( low and high byte of addres registers ) : al_ FSR1L_ ; : ah_ FSR1H_ ; : bl_ FSR2L_ ; : bh_ FSR2H_ ; ( register addressing modes: compiles literal for deref operation ) : a_ INDF1_ ; : a+_ POSTINC1_ ; : +a_ PREINC1_ ; : a-_ POSTDEC1_ ; : b_ INDF2_ ; : b+_ POSTINC2_ ; : +b_ PREINC2_ ; : b-_ POSTDEC2_ ; ( changing pointer ) : lit!a_ 1 lfsr_ ; ( literal set a ) : lit!b_ 2 lfsr_ ; ( literal set b ) ( save/restore a/b to return stack ) : a>r_ push_ al_ @_ rl_ !_ ah_ @_ rh_ !_ ; : b>r_ push_ bl_ @_ rl_ !_ bh_ @_ rh_ !_ ; : r>a_ rh_ @_ al_ !_ rl_ @_ ah_ !_ pop_ ; : r>b_ rh_ @_ bl_ !_ rl_ @_ bh_ !_ pop_ ; ( interrupt handlers ) : install-reset ( startword -- ) there >r ( save there ) ( compile relative jump to start routine ) 0x0 !there ( compile at 0x0 ) 0x40 rjump_ ( jump to 0x40 ) ( init routine: setup forth environment ) 0x40 !there ( compile at 0x40 ) movlw _ ( clear TOS ) 0x20 0 lfsr_ ( init data stack ptr ) movwf STKPTR op/ _ ( init return stack ptr ) rjump_ ( jump to start word ) r> !there ; ( restore there ) : install-ihigh ( intword -- ) there >r 0x8 !there ( move there to iv ) TMP_ @_ ( thanks to swap ) call_ ( call handling word ) TMP_ !_ retfie 1 or _ ( fast return ) r> !there ; : install-ilow ( intword -- ) there >r 0x18 !there STATUS_ @_ ( save flags ) TMP_ @_ call_ TMP_ !_ STATUS_ !_ ( restore flags ) retfie _ r> !there ; 0x80 !there ( start compiling forth code at 0x80 ) target ( host communication. execute word block program ) ( uart stuff ) ( port config ) ( timer ) host